home *** CD-ROM | disk | FTP | other *** search
/ Mac Magazin/MacEasy 32 / Mac Magazin and MacEasy Magazine CD - Issue 32.iso / Multimedia / MIDI / MidiChaos_15 Folder / MidiChaos_1.5 / Source / Tools / FloatingPoint < prev    next >
Text File  |  1990-09-19  |  10KB  |  482 lines
  1. \ Floating Point Support for H4th
  2. \ Use the SANE system from Apple
  3. \
  4. \ Please see the Standard Apple Numerics manual for more information.
  5. \ This code is based loosely on the upcoming ANSI Forth standard.
  6. \
  7. \ Work remaining:
  8. \    O- Better ANSI compliance
  9. \    O- Optimize stack ops
  10. \
  11. \ *********************************************************************
  12. \ * HMSL Forth System                                                 *
  13. \ * Author: Phil Burk                                                 *
  14. \ * Copyright 1989 Phil Burk , All Rights Reserved                    *
  15. \ *********************************************************************
  16. \
  17. \ MOD: 7/12/90 F> and F< now use FLOAT.2->0 to avoid leaving stuff on FSTACK
  18. \      F. smarter about style choices, added EXP.
  19. \      Fixed FLOG, Added FLOG2, sped up FSWAP and FROT
  20. \ MOD: PLB 7/18/90 Added F.R
  21. \ MOD: RDG 9/19/90 Changed fpinit and fpterm to support floating point members.
  22.  
  23. ANEW TASK-FLOATINGPOINT
  24. decimal
  25.  
  26. 32 constant FLOAT_STACK_SIZE
  27. 10 constant FLOAT_WIDTH
  28. create FLOAT-STACK FLOAT_WIDTH FLOAT_STACK_SIZE 2+ * ALLOT
  29.  
  30. variable FLOAT-STACK-PTR  ( pointer to top of floating point stack )
  31.  
  32. : F0SP  ( -- , reset float stack pointer )
  33. \ stack grows up
  34.     float-stack float-stack-ptr !
  35. ;
  36. f0sp
  37.  
  38. : FLOAT.CHECK  ( -- , check floating point stack )
  39.     float-stack-ptr @ dup float-stack <
  40.     IF ." Floating Pointing Stack Underflow!" cr f0sp abort
  41.     ELSE
  42.         float-stack  [  float_width float_stack_size * ] literal + >
  43.         IF ." Floating Point Stack Overflow!" cr f0sp abort
  44.         THEN
  45.     THEN
  46. ;
  47.  
  48. : FMOVE  ( addr1 addr2 -- , move floating point number , %Q optimize )
  49.     float_width cmove
  50. ;
  51.  
  52. : F@ ( addr -- , -f- f , fetch float )
  53.     float-stack-ptr @ float_width + dup float-stack-ptr !
  54.     fmove
  55. ;
  56.  
  57. : F! ( addr -- , f -f- , store float )
  58.     float-stack-ptr @ dup float_width - float-stack-ptr !
  59.     swap fmove
  60. ;
  61.  
  62. : FDEPTH  ( -- depth , number of items on float stack )
  63.     float-stack-ptr @ float-stack - float_width /
  64. ;
  65.  
  66. : FPICK  ( n -- , fn ... f1 f0 -- fn ... f1 f0 fn )
  67.     [ float_width negate ] literal * float-stack-ptr @ + f@
  68. ;
  69.  
  70. : FVARIABLE ( <name> -- )
  71.     CREATE float_width allot
  72. ;
  73. fvariable FTEMP  \ variable for storing temporary values for stack 
  74.  
  75. : FCONSTANT ( f -f- , <name> -- , make constant )
  76.     CREATE here f!   float_width allot
  77.     DOES> f@
  78. ;
  79.  
  80. : FDROP  ( f -f- , DROP floating point value )
  81.     [ float_width negate ] literal float-stack-ptr +!
  82. ;
  83.  
  84. : FDUP  ( f -f- f f, DUP floating point value )
  85.     float-stack-ptr @ f@
  86. ;
  87. : FOVER  ( fa fb -f- fa fb fa, OVER floating point value )
  88.     float-stack-ptr @ float_width - f@
  89. ;
  90.  
  91. : FSWAP  ( fa fb -f- fb fa, SWAP floating point value )
  92.     float-stack-ptr @ dup ftemp fmove  \ fb -> ftemp
  93.     dup float_width - dup>r swap fmove  \ fa -> top
  94.     ftemp r> fmove  \ ftemp -> second
  95. ;
  96.  
  97. : FROT  ( fa fb fc -f- fb fc fa, ROT floating point value )
  98.     float-stack-ptr @ [ float_width 2* ] literal - ftemp fmove
  99.     float-stack-ptr @ float_width  -
  100.     dup float_width - [ float_width 2* ] literal cmove
  101.     ftemp float-stack-ptr @ fmove
  102. ;
  103.  
  104. $ A9EB constant T_FP68K        
  105. $ A9EC constant T_Elems68K
  106. $ A9EE constant T_DECSTR68K
  107.  
  108. \ SANE Interface
  109. : CALLSANE  ( <number> <trap> -- , compile trap number with # on return stack )
  110.     ?comp
  111.     base @ hex
  112.     bl word number?
  113.     IF drop  $ 3F3C w,    w,   \ MOVE.S  #xx,-(A7)
  114.         bl word number?
  115.         IF drop   w,     \ TRAP
  116.         ELSE ." callsane - Not a valid number!" abort
  117.         THEN
  118.     ELSE ." callsane - Not a valid number!" abort
  119.     THEN
  120.     base !
  121. ; immediate
  122.  
  123. : FLOAT  ( n -- , -f- f , convert integer to float on stack )
  124. \ Push address of data stack and drop.
  125.     [    $ 2F0E w,    \ move.l  a6,-(a7)
  126.     ]
  127.     float-stack-ptr @ float_width + dup float-stack-ptr ! >r
  128.     callsane 280E  A9EB ( FL2X )
  129.     drop
  130. ;
  131.  
  132. : INT  ( -- n , f -f- , convert float to integer )
  133.     float-stack-ptr @ dup float_width - float-stack-ptr ! >r
  134. \ Push address of data stack and drop.
  135.     [    $ 598E w,    \ subq.l  #4,a6
  136.         $ 2F0E w,    \ move.l  a6,-(a7)
  137.     ]
  138.     callsane 2810  A9EB  ( FX2L )
  139. ;
  140.  
  141. : F>I  ( -- i , f -f- ,  Mach2 compatible )
  142.     int
  143. ;
  144.  
  145. : I>F  ( i -- , -- f ,  Mach2 compatible )
  146.     float
  147. ;
  148.  
  149. : FLOAT.2->0  ( -r- $dst $src , setup stack for binary operators )
  150.     r>  ( save return address )
  151.     float-stack-ptr @ dup >r 
  152.     float_width - dup >r 
  153.     float_width - float-stack-ptr !
  154.     >r  ( restore return adress )
  155. ;
  156.  
  157. : FLOAT.2->1  ( -r- $dst $src , setup stack for binary operators )
  158.     r>  ( save return address )
  159.     float-stack-ptr @ dup >r 
  160.     float_width - dup >r 
  161.     float-stack-ptr !
  162.     >r  ( restore return adress )
  163. ;
  164.  
  165. : FLOAT.1->1  ( -- $dst , setup stack for unary operators )
  166.     r>  ( save return address )
  167.     float-stack-ptr @ >r
  168.     >r  ( restore return adress )
  169. ;
  170.  
  171. : F*   ( f1 f2 -- f1*f2 )
  172.     float.2->1
  173.     callsane 0004  A9EB
  174. ;
  175.  
  176. : F+   ( f1 f2 -- f1+f2 )
  177.     float.2->1
  178.     callsane 0000  A9EB
  179. ;
  180.  
  181. : F-   ( f1 f2 -- f1-f2 )
  182.     float.2->1
  183.     callsane 0002  A9EB
  184. ;
  185.  
  186. : F/   ( f1 f2 -- f1/f2 )
  187.     float.2->1
  188.     callsane 0006  A9EB
  189. ;
  190.  
  191. : FSQRT  ( f -f- sqrt[f] )
  192.     float.1->1
  193.     callsane 0012  A9EB
  194. ;
  195.  
  196. : FMOD   ( f1 f2 -- rem[f1/f2] )
  197.     float.2->1
  198.     callsane 000C  A9EB
  199. ;
  200.  
  201. : FROUND  ( f -f- round[f] )
  202.     float.1->1
  203.     callsane 0014  A9EB
  204. ;
  205.  
  206. : FTRUNCATE  ( f -f- truncate[f] )
  207.     float.1->1
  208.     callsane 0016  A9EB
  209. ;
  210.  
  211. : FNEGATE  ( f -f- -f )
  212.     float.1->1
  213.     callsane 000D  A9EB
  214. ;
  215.  
  216. : FABS  ( f -f- abs[f] )
  217.     float.1->1
  218.     callsane 000F  A9EB
  219. ;
  220.  
  221. \ Floating Point Comparisons
  222. : COMPILE.FCOMP  ( -- , code fragment for comparison )
  223.     $ 42a6  w,    \    clr.l    -(a6)
  224.     $ 4E75  w,    \    rts
  225.     $ 2D3C    w,    $ FFFFFFFF , \    move.l    #$-1,-(a6)
  226. ; immediate
  227.  
  228. : FCMPX()  ( f1 f2 -- )
  229.     float.2->0
  230.     callsane 0008  A9EB
  231. ;
  232.  
  233. : F>  ( f1 f2 -- flag )
  234.     fcmpx()
  235.     [ $ 6E04 w, ]  \ BGT
  236.     compile.fcomp
  237. ;
  238.  
  239. : F<  ( f1 f2 -- flag )
  240.     fcmpx()
  241.     [ $ 6D04 w, ]  \ BLT
  242.     compile.fcomp
  243. ;
  244.  
  245. : F=  ( f1 f2 -- flag )
  246.     fcmpx()
  247.     [ $ 6704 w, ]  \ BEQ
  248.     compile.fcomp
  249. ;
  250.  
  251. \ Elementary Functions
  252. : FLN  ( f -- ln[f] )
  253.     float.1->1  callsane 0000 a9ec
  254. ;
  255. : FLOG2  ( f -- log2[f] )
  256.     float.1->1  callsane 0002 a9ec
  257. ;
  258. : FEXP  ( f -- exp[f] )
  259.     float.1->1  callsane 0008 a9ec
  260. ;
  261. : F**  ( fx fy -- fx**fy )
  262.     float.2->1  callsane 8012 a9ec
  263. ;
  264. : FSIN  ( f -- sin[f] )
  265.     float.1->1  callsane 0018 a9ec
  266. ;
  267. : FCOS  ( f -- cos[f] )
  268.     float.1->1  callsane 001A a9ec
  269. ;
  270. : FTAN  ( f -- tan[f] )
  271.     float.1->1  callsane 001C a9ec
  272. ;
  273. : FATAN  ( f -- atan[f] )
  274.     float.1->1  callsane 001E a9ec
  275. ;
  276. : FRANDOM  ( f -- random[f] )
  277.     float.1->1  callsane 0020 a9ec
  278. ;
  279.  
  280. variable SANE-ENVIRONMENT
  281.  
  282. : SANE.GETENV  ( -- envword , get environmental control word )
  283.     sane-environment >r
  284.     callsane 0003 A9EB
  285.     sane-environment w@
  286. ;
  287.  
  288. : SANE.SETENV  ( envword -- , set environmental control word )
  289.     sane-environment w!
  290.     sane-environment >r
  291.     callsane 0001 A9EB
  292. ;
  293.  
  294.  
  295. :STRUCT DecimalRecord
  296.     ushort    DR_SGN
  297.     short    DR_EXP
  298.     20 bytes    DR_STRING
  299. ;STRUCT
  300.  
  301. :STRUCT DecimalForm
  302.     ushort    DF_STYLE
  303.     ushort    DF_DIGITS
  304. ;STRUCT
  305.  
  306. -1 constant FP_DECIMAL_STYLE
  307. 0 constant FP_EXP_STYLE
  308.  
  309. \ Declare stock structures for use with conversion.
  310. DecimalRecord FP-DecRec
  311. DecimalForm FP-DecForm
  312. \ Input Conversion
  313. variable VALID-PREFIX
  314. variable FSTR-OFFSET
  315.  
  316. : FSTR2DEC  ( string -- 1=ok | 0=bad , build decimal record )
  317.     >r
  318.     1 fstr-offset dup >r w!
  319.     fp-decRec >r
  320.     valid-prefix >r
  321.     callsane 0002 A9EE
  322.     valid-prefix c@
  323. ;
  324.  
  325. : FDEC2X ( -f- f , convert record to X )
  326.     fp-decrec >r
  327.     float-stack-ptr @ float_width + dup >r float-stack-ptr !
  328.     callsane 0009 A9EB
  329.     float.check
  330. ;
  331.  
  332. : FNUMBER?  ( $string -- true | false , -f- f | , convert if valid )
  333.     fstr2dec
  334.     IF fdec2x true
  335.     ELSE false
  336.     THEN
  337. ;
  338.  
  339. defer OLD.RECOGNIZE
  340.  
  341. : (FLIT) ( fnum-inline , -f- f , get from inline, put on f-stack )
  342.     r> dup f@
  343.     float_width +
  344.     >r
  345. ;
  346.  
  347. : F,  ( f -f- , compile fnum into dictionary )
  348.     here f!
  349.     float_width allot
  350. ;
  351.  
  352. : FLITERAL  ( f -f- , )
  353.     state @
  354.     IF    compile (flit) f,
  355.     THEN
  356. ;
  357. : FNUMLIT  ( $string -- flag , -f- f , if true )
  358.     fnumber? dup
  359.     IF fliteral
  360.     THEN
  361. ;
  362.  
  363. : FRECOGNIZE ( $string -- flag )
  364.     dup old.recognize  ( -- $string flag )
  365.     IF drop true   ( recognized by something else )
  366.     ELSE ( -- $string )
  367.         base @ $ 10 -  ( make sure not in hex mode )
  368.         IF  dup ascii . index
  369.             IF ( -- $string addr ) drop fnumlit
  370.             ELSE dup ascii E index
  371.                 IF drop fnumlit
  372.                 ELSE drop false
  373.                 THEN
  374.             THEN
  375.         ELSE drop false
  376.         THEN 
  377.     THEN
  378. ;
  379.  
  380. variable IF-FP-INIT
  381.  
  382. : FPINIT  ( -- )
  383.     f0sp
  384.     if-fp-init @ 0=
  385.     IF    what's recognize is old.recognize
  386.         'c frecognize is recognize
  387.         'c f! is s.f!  \ s.f! and s.f@ are defered in my_struct
  388.         'c f@ is s.f@
  389.         if-fp-init on
  390.     THEN
  391. ;
  392.  
  393. : FPTERM  ( -- )
  394.     if-fp-init @
  395.     IF    what's old.recognize is recognize
  396.         'c noop dup is s.f! is s.f@  \ reset deferred words
  397.         if-fp-init off
  398.     THEN
  399. ;
  400.  
  401. fpinit
  402. 10.0 flog2 fconstant 10FLOG2
  403. 1.0 fatan 4.0 f* fconstant PI
  404. fpterm
  405.  
  406. : FLOG  ( f -f- log[f] , base 10 )
  407.     flog2 10flog2 f/
  408. ;
  409.  
  410. \ Output Conversion
  411.  
  412. : FDec2Str ( -- string )
  413.     fp-decForm >r
  414.     fp-decRec >r
  415.     pad >r
  416.     callsane 0003 A9EE
  417.     pad
  418. ;
  419.  
  420. : FX2Dec ( f -f- , load stock records )
  421.     fp-decForm >r
  422.     float-stack-ptr @ dup float_width - float-stack-ptr ! >r
  423.     fp-decRec >r
  424.     callsane 000B A9EB
  425. ;
  426.  
  427. : PLACES  ( n -- , set number of significant or fractional digits )
  428.     fp-decform ..! df_digits
  429. ;
  430. 6 places
  431.  
  432. : (F>TEXT)  ( f -f-  , style -- addr count )
  433.     float.check
  434.     fp-decForm ..! df_style    \ force style
  435.     fx2dec
  436.     fdec2str
  437.     count
  438.     float.check
  439. ;
  440.  
  441. variable FP-SWITCH
  442. 8 FP-SWITCH !
  443.  
  444. : F>TEXT  ( f -f-  , -- addr count )
  445.     fdup flog fabs int fp-switch @ > 0=
  446.     (f>text)
  447. ;
  448.  
  449. : F.R  ( f -f- , nchars -- )
  450.     >r f>text r> over - 0 max spaces type
  451. ;
  452.  
  453. : EXP.R  ( f -f- , nchars -- )
  454.     >r fp_exp_style (f>text) r> over - 0 max spaces type
  455. ;
  456.  
  457. : F.  ( f -f- )
  458.     f>text type space
  459. ;
  460.  
  461. : EXP.  ( f -f- )
  462.     fp_exp_style (f>text) type space
  463. ;
  464.  
  465. : F.S  ( -- dump floating point stack )
  466.     >newline fdepth 0>
  467.     IF fdepth float_stack_size >
  468.         IF ." Float Stack Overflow!" f0sp abort
  469.         ELSE ." FPStack: " fdepth 0
  470.             DO fdepth i - 1- fpick f. cr?
  471.             LOOP
  472.         THEN
  473.     ELSE fdepth 0=
  474.         IF ." Float Stack Empty"
  475.         ELSE ." Float Stack Underflow" f0sp abort
  476.         THEN
  477.     THEN cr
  478. ;
  479.  
  480. if.forgotten fpterm
  481. cr ." Enter:   FPINIT    before using!" cr
  482.